home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / pc_board / sfa.zip / SFA.PAS < prev   
Pascal/Delphi Source File  |  1991-10-13  |  10KB  |  280 lines
  1. program SetFileArea;
  2. uses Dos;
  3.  
  4. {
  5. Title   : SFA.PAS  (Changes privileges of ALL files in one area in FILESBBS.DAT)
  6. Version : 1.0 -- *ONLY* For Opus 1.7x or above
  7. LastEdit: October 13, 1991 -- For exclusive use of his Boss Alberto Enna
  8. Author  : Gianfranco "Frankie" Lanzilli - CoSysOp on ]\/[imac Opus BBs (+39-6-2751446) Rome,Italy - 2:335/12@fidonet.org
  9. System  : Borland Turbo Pascal v5.5 (MS-DOS)
  10. }
  11.  
  12. const ItemLen = 64;
  13.  
  14. var FNam     : string;
  15.     FDat     : file of byte;
  16.     FPos     : longint;
  17.     ANum     : word;
  18.     FPF, FPT : byte;
  19.  
  20. procedure Configure;
  21.   var ThisExeFile : file of char;
  22.       CheckString : string[4];
  23.       FAttr       : word;
  24.       FTime       : longint;
  25.       C, K        : char;
  26.       I           : byte;
  27.  
  28.   function KeyPressed : boolean;
  29.     var Regs : Registers;
  30.     begin  {KeyPressed}
  31.       Regs.AH := $0B;
  32.       MsDos(Regs);
  33.       case Regs.AL of
  34.         $00 : KeyPressed := false;
  35.         $FF : KeyPressed := true
  36.       end  {case}
  37.     end;  {KeyPressed}
  38.  
  39.   function ReadKey : char;
  40.     var Regs : Registers;
  41.     begin  {ReadKey}
  42.       Regs.AH := $08;
  43.       Msdos(Regs);
  44.       ReadKey := Chr(Regs.AL)
  45.     end;  {ReadKey}
  46.  
  47.   begin  {Configure}
  48.     Assign(ThisExeFile,ParamStr(0));
  49.     GetFAttr(ThisExeFile,FAttr);
  50.     SetFAttr(ThisExeFile,Archive);
  51.     Reset(ThisExeFile);
  52.     GetFTime(ThisExeFile,FTime);
  53.     Seek(ThisExeFile,(FileSize(ThisExeFile)-4));
  54.     CheckString := '';
  55.     for I := 1 to 4 do
  56.       begin
  57.         Read(ThisExeFile,C);
  58.         CheckString := (CheckString + C)
  59.       end;
  60.     if (CheckString <> '*SFA') then
  61.       begin
  62.         Writeln(' Frankie''s SetFileAreas v1.0');
  63.         Writeln(' ~~~~~~~~~~~~~~~~~~~~~~~~~~~');
  64.         Writeln(' This copy of the program has NOT been configured yet.');
  65.         Writeln(' Configuration is quick and easy; please input at the prompt the pathname');
  66.         Writeln(' of your Opus 1.7x FilesBbs.Dat; for example: C:\OPUS\FILESBBS.DAT.');
  67.         Writeln;
  68.         Writeln(' Now, type in, or press <Control-Break> to stop:');
  69.         Write(' FilesBbsDatFile>');
  70.         Readln(FNam);
  71.         Writeln;
  72.         Writeln(' Thank you.');
  73.         Writeln(' If you made a mistake, you can press <Control-Break> to stop now, before the');
  74.         Writeln(' configuration is written to the EXE file, or press <Return> if all is OK.');
  75.         Writeln(' Remember, there''s no way to change this configuration, so if you want to do');
  76.         Writeln(' so, you should restart with a brand new copy of the program.');
  77.         Writeln;
  78.         Writeln(' IMPORTANT: the EXE file of the program cannot be compressed when configured!');
  79.         Writeln('            However, it has already been compressed with PkLite by me.');
  80.         Writeln;
  81.         Writeln('                             Gianfranco "Frankie" Lanzilli');
  82.         Writeln('      CoSysOp Opus ]\/[imac BBs - FidoNet 2:335/12 - +39-6-2751446 - Roma, Italy');
  83.         Write(' Press <Return> to continue, or <Control-Break> to abort...');
  84.         repeat
  85.           repeat until KeyPressed;
  86.           C := ReadKey;
  87.           if (C = #0) then
  88.             K := ReadKey
  89.         until (C = #13);
  90.         Writeln;
  91.         Writeln;
  92.         Seek(ThisExeFile,FileSize(ThisExeFile));
  93.         C := '*';
  94.         Write(ThisExeFile,C);
  95.         while ((FNam[1] = #9) or (FNam[1] = #32)) do
  96.           Delete(FNam,1,1);
  97.         while ((FNam[Length(FNam)] = #9) or (FNam[Length(FNam)] = #32)) do
  98.           Delete(FNam,Length(FNam),1);
  99.         for I := 1 to Length(FNam) do
  100.           begin
  101.             Seek(ThisExeFile,FileSize(ThisExeFile));
  102.             C := UpCase(FNam[I]);
  103.             Write(ThisExeFile,C)
  104.           end;
  105.         CheckString := '*SFA';
  106.         for I := 1 to Length(CheckString) do
  107.           begin
  108.             Seek(ThisExeFile,FileSize(ThisExeFile));
  109.             Write(ThisExeFile,CheckString[I])
  110.           end;
  111.         SetFTime(ThisExeFile,FTime);
  112.         Close(ThisExeFile);
  113.         SetFAttr(ThisExeFile,FAttr)
  114.       end
  115.     else
  116.       Close(ThisExeFile)
  117.   end;  {Configure}
  118.  
  119. procedure GetName (var N : string);
  120.   var ThisExeFile : file of char;
  121.       C           : char;
  122.   begin  {GetName}
  123.     Assign(ThisExeFile,ParamStr(0));
  124.     Reset(ThisExeFile);
  125.     Seek(ThisExeFile,(FileSize(ThisExeFile)-5));
  126.     Read(ThisExeFile,C);
  127.     N := '';
  128.     while (C <> '*') do
  129.       begin
  130.         N := C + N;
  131.         Seek(ThisExeFile,(FilePos(ThisExeFile)-2));
  132.         Read(ThisExeFile,C)
  133.       end;
  134.     Close(ThisExeFile)
  135.   end;  {GetName}
  136.  
  137. procedure CheckCommandLine (var AN : word; var PF, PT : byte);
  138.  
  139.   function PrivByte (Privilege : string) : byte;
  140.     var K : byte;
  141.     begin  {PrivByte}
  142.       for K := 1 to Length(Privilege) do
  143.         Privilege[K] := UpCase(Privilege[K]);
  144.       if (Privilege = 'TWIT') then       PrivByte := $10  else
  145.         if (Privilege = 'DISGRACE') then   PrivByte := $30  else
  146.           if (Privilege = 'LIMITED') then    PrivByte := $40  else
  147.             if (Privilege = 'NORMAL') then     PrivByte := $50  else
  148.               if (Privilege = 'WORTHY') then     PrivByte := $60  else
  149.                 if (Privilege = 'PRIVIL') then     PrivByte := $70  else
  150.                   if (Privilege = 'FAVORED') then    PrivByte := $80  else
  151.                     if (Privilege = 'EXTRA') then      PrivByte := $90  else
  152.                       if (Privilege = 'CLERK') then      PrivByte := $A0  else
  153.                         if (Privilege = 'ASSTSYSOP') then  PrivByte := $B0  else
  154.                           if (Privilege = 'SYSOP') then      PrivByte := $D0  else
  155.                             if (Privilege = 'HIDDEN') then     PrivByte := $E0  else
  156.                               begin
  157.                                 Writeln;
  158.                                 Writeln('"',Privilege,'" is NOT a valid Privilege Class.');
  159.                                 Writeln('Choose one of the following:');
  160.                                 Writeln('  01> Twit       04> Normal      07> Favored     10> AsstSysop');
  161.                                 Writeln('  02> Disgrace   05> Worthy      08> Extra       11> Sysop');
  162.                                 Writeln('  03> Limited    06> Privil      09> Clerk       12> Hidden');
  163.                                 Halt
  164.                               end
  165.     end;  {PrivByte}
  166.  
  167.   function Get_Word (S : string) : word;
  168.     var Aux : longint;
  169.         Err : integer;
  170.     begin {Get_Word}
  171.       Val(S,Aux,Err);
  172.       if ((Err > 0) or ((Err = 0) and ((Aux < 0) or (Aux > 65535)))) then
  173.         begin
  174.           Writeln;
  175.           Writeln('"',S,'" is NOT a valid Area Number.');
  176.           Writeln('This should be a INTEGER value in the range: 0 .. 65535.');
  177.           Halt
  178.         end
  179.       else
  180.         Get_Word := Aux
  181.     end;  {Get_Word}
  182.  
  183.   begin  {CheckCommandLine}
  184.     if (ParamCount <> 3) then
  185.       begin
  186.         Writeln;
  187.         Writeln('Usage:  SFA <AreaNumber> <PrivilegeFrom> <PrivilegeTo>');
  188.         Writeln;
  189.         Writeln(' If the download privilege of a file in area <AreaNumber> is <PrivilegeFrom>,');
  190.         Writeln(' then it is set to <PrivilegeTo>.');
  191.         Writeln;
  192.         Writeln(' <AreaNumber> must be an INTEGER value in the range: 0 .. 65535.');
  193.         Writeln;
  194.         Writeln(' Possible values for <PrivilegeFrom> and <PrivilegeTo> are:');
  195.         Writeln('   Twit       Limited     Worthy      Favored     Clerk       Sysop');
  196.         Writeln('   Disgrace   Normal      Privil      Extra       AsstSysop   Hidden');
  197.         Writeln;
  198.         Writeln(' **** Yet another Frankie''s production, 1991 ****');
  199.         Halt
  200.       end
  201.     else
  202.       begin
  203.         AN := Get_Word(ParamStr(1));
  204.         PF := PrivByte(ParamStr(2));
  205.         PT := PrivByte(ParamStr(3))
  206.       end
  207.   end;  {CheckCommandLine}
  208.  
  209. function PrivStr (PC : byte) : string;
  210.   begin  {PrivStr}
  211.     case PC of
  212.       $10 : PrivStr := 'Twit';
  213.       $30 : PrivStr := 'Disgrace';
  214.       $40 : PrivStr := 'Limited';
  215.       $50 : PrivStr := 'Normal';
  216.       $60 : PrivStr := 'Worthy';
  217.       $70 : PrivStr := 'Privil';
  218.       $80 : PrivStr := 'Favored';
  219.       $90 : PrivStr := 'Extra';
  220.       $A0 : PrivStr := 'Clerk';
  221.       $B0 : PrivStr := 'AsstSysop';
  222.       $D0 : PrivStr := 'Sysop';
  223.       $E0 : PrivStr := 'Hidden'
  224.     end {case}
  225.     end;  {PrivStr}
  226.  
  227. procedure SetFile (var FP : longint; AN : word; PF, PT : byte);
  228.   var B1, B2 : byte;
  229.       FN     : string[13];
  230.   begin  {SetFile}
  231.     Read(FDat,B1);  Read(FDat,B2);
  232.     if ((B1+(B2*256)) = AN) then
  233.       begin
  234.         Seek(FDat,(FP+15));
  235.         Read(FDat,B1);
  236.         if (B1 = PF) then
  237.           begin
  238.             Seek(FDat,(FP+2));
  239.             FN := '';
  240.             for B1 := 1 to 13 do
  241.               begin
  242.                 Read(FDat,B2);
  243.                 if (B2 = 0) then  B2 := 32;
  244.                 FN := FN + Chr(B2)
  245.               end;
  246.             Seek(FDat,(FP+15));
  247.             Write(FDat,PT);
  248.             Writeln(AN,'  "',FN,'"  ',PrivStr(PF),' -=> ',PrivStr(PT))
  249.           end
  250.       end;
  251.     Seek(FDat,(FP+36));  Read(FDat,B1);  Read(FDat,B2);  FP := FP + (B1+(B2*256));
  252.     Read(FDat,B1);  FP := FP + B1;
  253.     Read(FDat,B1);  FP := FP + B1;
  254.     FP := FP + ItemLen;
  255.     Seek(FDat,FP)
  256.   end;  {SetFile}
  257.  
  258. begin  {MAIN}
  259.   Configure;
  260.   GetName(FNam);
  261.   CheckCommandLine(ANum,FPF,FPT);
  262.   Writeln;
  263.   Assign(FDat,FNam);
  264.   {$I-} Reset(FDat); {$I+}
  265.   if (IOResult <> 0) then
  266.     begin
  267.       Writeln;
  268.       Writeln('Can''t open FilesBbsDat File ',FNam,'.');
  269.       Writeln('Please correct the problem or re-install the program from an original copy.');
  270.       Halt
  271.     end
  272.   else
  273.     begin
  274.       Writeln('Setting download privilege of files in area ',ANum,' from ',PrivStr(FPF),' to ',PrivStr(FPT),'.');
  275.       FPos := 0;
  276.       while (not Eof(FDat)) do
  277.         SetFile(FPos,ANum,FPF,FPT);
  278.       Close(FDat)
  279.     end
  280. end.  {MAIN}